C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C ----------------------------------------------------------------------
C
C       I S T M E   -   Mung Expressions
C
C       This program reads in a parse tree and works over expressions
C       rearranging them so as to minimise the stack depth needed either
C       to parse them or evaluate them (the latter is done easily except
C       by the most stupid compilers, but you can never be too sure...).
C       The only things assumed are that addition and multiplication are
C       commutative.
C
C       Programmed by: Malcolm Cohen, Numerical Algorithms Group,
C                      January 1986.
C
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
        PROGRAM ISTME
 
        INTEGER IODTRI,IODTRO,TROPTH(81),TRIPTH(81)
 
        INTEGER GETARG,OPEN,CREATE
        EXTERNAL GETARG,OPEN,CREATE,ZYINPT,ZYTOUT,ZINIT,ZQUIT,ZMESS,
     +           ERROR
 
        CALL ZINIT
 
        IF (GETARG(1,TRIPTH,81).EQ.-100) CALL MEARGS(1,TRIPTH)
        IF (GETARG(2,TROPTH,81).EQ.-100) CALL MEARGS(2,TROPTH)
 
        IODTRI=OPEN(TRIPTH,0)
        IF (IODTRI.EQ.-1) CALL ERROR('Can''t open input parse tree')
        IODTRO=CREATE(TROPTH,1)
        IF (IODTRO.EQ.-1) CALL ERROR('Can''t create output parse tree')
 
        CALL ZYINPT(IODTRI)
 
        CALL PROTRE
 
        CALL ZYTOUT(IODTRO)
        CALL ZMESS('[ISTME Normal Termination]',1)
        CALL ZQUIT(-2)
 
        END
C ----------------------------------------------------------------------
C
C       M E A R G S   -   Get an argument for ISTME
C
 
        SUBROUTINE MEARGS(N,ARG)
        INTEGER N,ARG(81)
 
        INTEGER I,PROMPT(20,2)
 
        INTEGER ZGTCMD
        EXTERNAL ZGTCMD,ZPRMPT,ERROR
 
        DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
     +97,114,115,101,32,116,114,101,101,58,32,129/,
     +       (PROMPT(I,2),I=1,20)/79,117,116,112,117,116,32,
     +112,97,114,115,101,32,116,114,101,101,58,32,
     +129/
 
        CALL ZPRMPT(PROMPT(1,N))
        IF (ZGTCMD(ARG,0).EQ.-1) CALL ERROR('ZGTCMD failed')
 
        END
C ----------------------------------------------------------------------
C
C       P R O T R E   -   Process the parse tree
C
C       This routine looks at each statement in the parse tree.  If it
C       finds an assignment statement, it then calls EXPRES with the
C       right-hand side to do the work of munging it.
C
 
        SUBROUTINE PROTRE
 
        INTEGER SPTR,PUPTR,PTR,PUNUM,STMTNO
 
        INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZYNTYP
 
        PUPTR=ZYDOWN(ZYROOT())
        PUNUM=1
 
 100    SPTR=ZYDOWN(PUPTR)
        STMTNO=1
 200    IF (ZYNTYP(SPTR).EQ.49) THEN
C Found an assignment statement - work over its expression
            PTR=ZYDOWN(SPTR)
            IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
            CALL EXPRES(ZYNEXT(PTR),PUNUM,STMTNO)
        END IF
        SPTR=ZYNEXT(SPTR)
        STMTNO=STMTNO+1
        IF (SPTR.NE.0) GOTO 200
        PUPTR=ZYNEXT(PUPTR)
        PUNUM=PUNUM+1
        IF (PUPTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       E X P R E S   -   Expression munging
C
C       This routine works over an expression, putting the most deeply
C       nested sub-expressions of "+" and "*" operators on the left-hand
C       side (to make parsing easier).
C
C       We do not however swap sides when the tree structure comes from
C       the left-to-right ordering of equal priority operators - in this
C       case the existing ordering is preserved (in case some of the
C       operands are of differing data types).
C
C       It also checks to make sure the depth of nesting of parentheses
C       is not too large (parameter MAXDEP).
C
 
        SUBROUTINE EXPRES(NODE,PUNUM,STMTNO)
        INTEGER NODE,PUNUM,STMTNO
 
        INTEGER MAXDEP
        PARAMETER (MAXDEP=16)
 
        INTEGER PTR,LHS,RHS,NEXTP,PDEPTH,NTYPE1,NTYPE2
        LOGICAL WARNED
 
        INTEGER DEPTH
 
        INTEGER ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYCRND
        EXTERNAL ZCHOUT,ZPTINT,PUTCH,ZYADNX,ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,
     +           ZYREPL,ZYCRND
 
        PTR=NODE
        PDEPTH=0
        WARNED=.FALSE.
 100    NTYPE1=ZYNTYP(PTR)
        IF (NTYPE1.EQ.95) THEN
            LHS=ZYDOWN(PTR)
            NTYPE1=ZYNTYP(LHS)
            RHS=ZYNEXT(LHS)
            NTYPE2=ZYNTYP(RHS)
            IF (NTYPE1.NE.95 .AND. NTYPE1.NE.96 .AND.
     +          NTYPE2.NE.95 .AND. NTYPE2.NE.96) THEN
                IF (NTYPE1.EQ.97) THEN
                    IF (DEPTH(LHS).LT.DEPTH(RHS)) THEN
C If the left-hand-side started with a monadic plus operator, remove it
                        CALL ZYDELT(LHS)
                        CALL ZYADNX(ZYDOWN(LHS),RHS)
                    END IF
                ELSE IF (NTYPE1.EQ.46) THEN
                    IF (DEPTH(LHS)+1.LT.DEPTH(RHS)) THEN
C If the lhs started with a monadic minus, put parentheses around it
                        CALL ZYDELT(LHS)
                        LHS=ZYCRND(101,LHS)
                        CALL ZYADNX(LHS,RHS)
                    END IF
                ELSE IF (DEPTH(LHS).LT.DEPTH(RHS)) THEN
                    CALL ZYADNX(LHS,RHS)
                END IF
            END IF
        ELSE IF (NTYPE1.EQ.98) THEN
            LHS=ZYDOWN(PTR)
            NTYPE1=ZYNTYP(LHS)
            RHS=ZYNEXT(LHS)
            NTYPE2=ZYNTYP(RHS)
            IF (NTYPE1.NE.98 .AND. NTYPE1.NE.99 .AND.
     +          NTYPE2.NE.98 .AND. NTYPE2.NE.99) THEN
                IF (NTYPE1.EQ.97) THEN
                    IF (DEPTH(LHS).LT.DEPTH(RHS)) THEN
C If the left-hand-side started with a monadic plus operator, remove it
                        CALL ZYDELT(LHS)
                        CALL ZYADNX(ZYDOWN(LHS),RHS)
                    END IF
                ELSE IF (NTYPE1.EQ.46) THEN
                    IF (DEPTH(LHS)+1.LT.DEPTH(RHS)) THEN
C If the lhs started with a monadic minus, put parentheses around it
                        CALL ZYDELT(LHS)
                        LHS=ZYCRND(101,LHS)
                        CALL ZYADNX(LHS,RHS)
                    END IF
                ELSE IF (DEPTH(LHS).LT.DEPTH(RHS)) THEN
                    CALL ZYADNX(LHS,RHS)
                END IF
            END IF
        ELSE IF (NTYPE1.EQ.101) THEN
            PDEPTH=PDEPTH+1
            IF (PDEPTH.GT.MAXDEP .AND. .NOT.WARNED) THEN
                WARNED=.TRUE.
                CALL ZCHOUT('Expression too deep at statement ',2)
                CALL ZPTINT(STMTNO,1,2)
                CALL ZCHOUT(' in program-unit ',2)
                CALL ZPTINT(PUNUM,1,2)
                CALL PUTCH(10,2)
            END IF
        END IF
        NEXTP=ZYDOWN(PTR)
        IF (NEXTP.LE.0) THEN
            NEXTP=ZYNEXT(PTR)
            IF (NEXTP.EQ.0) THEN
                IF (PTR.EQ.NODE) RETURN
 200            PTR=ZYUP(PTR)
                IF (PTR.EQ.NODE) RETURN
                IF (ZYNTYP(PTR).EQ.101) PDEPTH=PDEPTH-1
                NEXTP=ZYNEXT(PTR)
                IF (NEXTP.EQ.0) GOTO 200
            END IF
        END IF
        PTR=NEXTP
        GOTO 100
 
 
        END
C ----------------------------------------------------------------------
C
C       D E P T H   -   Return depth of a subtree
C
 
        INTEGER FUNCTION DEPTH(NODE)
        INTEGER NODE
 
        INTEGER PTR,D,NEXTP
 
        INTEGER ZYDOWN,ZYNEXT,ZYUP
        EXTERNAL ZYDOWN,ZYNEXT,ZYUP
 
        DEPTH=0
        PTR=ZYDOWN(NODE)
        IF (PTR.LE.0) RETURN
        DEPTH=1
        D=1
 100    NEXTP=ZYDOWN(PTR)
        IF (NEXTP.GT.0) THEN
            D=D+1
            DEPTH=MAX(DEPTH,D)
        ELSE
            NEXTP=ZYNEXT(PTR)
            IF (NEXTP.EQ.0) THEN
 200            PTR=ZYUP(PTR)
                IF (PTR.EQ.NODE) RETURN
                D=D-1
                NEXTP=ZYNEXT(PTR)
                IF (NEXTP.EQ.0) GOTO 200
            END IF
        END IF
        PTR=NEXTP
        GOTO 100
 
        END
